home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
c
/
main.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
15KB
|
905 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
main.c
IMPLEMENTATION-DEPENDENT
*/
#include "include.h"
bool saving_system = FALSE;
#ifdef BSD
#include <sys/time.h>
#include <sys/resource.h>
#endif
#ifdef AOSVS
#endif
#define MAXPATHLEN 1024
char lisp_implementation_version[] = "June 1987";
char system_directory[MAXPATHLEN];
object siVsystem_directory;
#ifdef UNIX
char *kcl_self;
#endif
char stdin_buf[BUFSIZ];
char stdout_buf[BUFSIZ];
int debug; /* debug switch */
int initflag = FALSE; /* initialized flag */
int real_maxpage;
object siVlisp_maxpages;
object siClisp_pagesize;
object siStop_level;
int ARGC;
char **ARGV;
#ifdef UNIX
char **ENVP;
#endif
static object defmacro_data;
static object evalmacros_data;
static object top_data;
static object module_data;
char *merge_system_directory();
int cssize;
#ifdef UNIX
main(argc, argv, envp)
int argc;
char **argv, **envp;
#else
main(argc, argv)
int argc;
char **argv;
#endif
{
FILE *i;
#ifdef BSD
struct rlimit rl;
#endif
#ifdef AOSVS
#endif
setbuf(stdin, stdin_buf);
setbuf(stdout, stdout_buf);
ARGC = argc;
ARGV = argv;
#ifdef UNIX
ENVP = envp;
#endif
#ifdef UNIX
/*
if (argv[0][0] != '/')
error("can't get the program name");
*/
kcl_self = argv[0];
if (!initflag) {
strcpy(system_directory, argv[0]);
if (system_directory[0] != '/')
strcpy(system_directory, "./");
else {
int j;
for (j = strlen(system_directory);
system_directory[j-1] != '/'; --j)
;
system_directory[j] = '\0';
}
}
#endif
#ifdef AOSVS
#endif
if (!initflag && argc > 1) {
#ifdef UNIX
if (argv[1][strlen(argv[1])-1] != '/')
#endif
#ifdef AOSVS
#endif
error("can't get the system directory");
strcpy(system_directory, argv[1]);
}
GBC_enable = FALSE;
vs_top = vs_base = vs_org;
vs_limit = &vs_org[VSSIZE];
frs_top = frs_org-1;
frs_limit = &frs_org[FRSSIZE];
bds_top = bds_org-1;
bds_limit = &bds_org[BDSSIZE];
ihs_top = ihs_org-1;
ihs_limit = &ihs_org[IHSSIZE];
cs_org = &argc;
cssize = CSSIZE;
#ifdef BSD
getrlimit(RLIMIT_STACK, &rl);
cssize = rl.rlim_cur/4 - 4*CSGETA;
#endif
#ifdef AV
cs_limit = cs_org - cssize;
#endif
#ifdef MV
#endif
set_maxpage();
if (initflag) {
if (saving_system) {
saving_system = FALSE;
alloc_page(-(holepage + nrbpage));
}
initflag = FALSE;
GBC_enable = TRUE;
vs_base = vs_top;
ihs_push(Cnil);
lex_new();
vs_base = vs_top;
#ifdef AOSVS
#endif
interrupt_enable = TRUE;
#ifdef UNIX
init_interrupt();
#endif
siVlisp_maxpages->s.s_dbind = make_fixnum(real_maxpage);
initflag = TRUE;
super_funcall(siStop_level);
exit(0);
}
printf("KCl (Kyoto Common Lisp) %s %d pages\n",
lisp_implementation_version,
MAXPAGE);
fflush(stdout);
init();
vs_base = vs_top;
ihs_push(Cnil);
lex_new();
GBC_enable = TRUE;
CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
init_init();
Vpackage->s.s_dbind = user_package;
lex_new();
vs_base = vs_top;
initflag = TRUE;
interrupt_enable = TRUE;
#ifdef UNIX
init_interrupt();
#endif
/* Primitive read-eval-print loop for debugging. */
/*
for (;;) {
vs_base = vs_top;
vs_push(code_char('>'));
Lwrite_char();
vs_base = vs_top;
Lfinish_output();
vs_base = vs_top;
Lread();
Leval();
vs_top = vs_base+1;
Lprin1();
vs_base = vs_top;
Lterpri();
}
*/
/* Now, init.lsp is loaded by si:top-level. */
/*
#ifdef UNIX
if ((i = fopen("./init.lsp", "r")) != NULL) {
fclose(i);
load("./init.lsp");
}
#endif
#ifdef AOSVS
#endif
*/
super_funcall(siStop_level);
}
init()
{
int j;
init_alloc();
Cnil_body.t = (short)t_symbol;
Cnil_body.s_dbind = Cnil;
Cnil_body.s_sfdef = NOT_SPECIAL;
Cnil_body.s_fillp = 3;
Cnil_body.s_self = "NIL";
Cnil_body.s_gfdef = OBJNULL;
Cnil_body.s_plist = Cnil;
Cnil_body.s_hpack = Cnil;
Cnil_body.s_stype = (short)stp_constant;
Cnil_body.s_mflag = FALSE;
Ct_body.t = (short)t_symbol;
Ct_body.s_dbind = Ct;
Ct_body.s_sfdef = NOT_SPECIAL;
Ct_body.s_fillp = 1;
Ct_body.s_self = "T";
Ct_body.s_gfdef = OBJNULL;
Ct_body.s_plist = Cnil;
Ct_body.s_hpack = Cnil;
Ct_body.s_stype = (short)stp_constant;
Ct_body.s_mflag = FALSE;
init_symbol();
init_package();
Cnil->s.s_hpack = lisp_package;
import(Cnil, lisp_package);
export(Cnil, lisp_package);
Ct->s.s_hpack = lisp_package;
import(Ct, lisp_package);
export(Ct, lisp_package);
Squote = make_ordinary("QUOTE");
enter_mark_origin(&Squote);
Sfunction = make_ordinary("FUNCTION");
enter_mark_origin(&Sfunction);
Slambda = make_ordinary("LAMBDA");
enter_mark_origin(&Slambda);
Slambda_block = make_ordinary("LAMBDA-BLOCK");
enter_mark_origin(&Slambda_block);
Slambda_closure = make_ordinary("LAMBDA-CLOSURE");
enter_mark_origin(&Slambda_closure);
Slambda_block_closure = make_ordinary("LAMBDA-BLOCK-CLOSURE");
enter_mark_origin(&Slambda_block_closure);
Sspecial = make_ordinary("SPECIAL");
enter_mark_origin(&Sspecial);
init_typespec();
init_number();
init_character();
init_file();
init_read();
init_bind();
init_pathname();
init_print();
init_GBC();
#ifdef UNIX
#ifndef DGUX
init_unixfasl();
init_unixsys();
init_unixsave();
#else
#endif
#endif
#ifdef AOSVS
#endif
init_alloc_function();
init_array_function();
init_character_function();
init_file_function();
init_list_function();
init_package_function();
init_pathname_function();
init_predicate_function();
init_print_function();
init_read_function();
init_sequence_function();
init_structure_function();
init_string_function();
init_symbol_function();
init_typespec_function();
init_hash();
init_cfun();
#ifdef UNIX
init_unixfsys();
init_unixtime();
#endif
#ifdef AOSVS
#endif
init_eval();
init_lex();
init_prog();
init_catch();
init_block();
init_macros();
init_conditional();
init_reference();
init_assignment();
init_multival();
init_error();
init_let();
init_mapfun();
init_iteration();
init_toplevel();
init_cmpaux();
init_main();
init_format();
#ifdef AOSVS
#endif
init_interrupt1();
}
/* init_init is now defined in init_system.c */
/*
init_init()
{
load(merge_system_directory("export.lsp"));
#ifdef UNIX
defmacro_data = read_fasl_data(merge_system_directory("defmacro.o"));
enter_mark_origin(&defmacro_data);
init_defmacro(NULL, 0, defmacro_data);
evalmacros_data
= read_fasl_data(merge_system_directory("evalmacros.o"));
enter_mark_origin(&evalmacros_data);
init_evalmacros(NULL, 0, evalmacros_data);
top_data = read_fasl_data(merge_system_directory("top.o"));
enter_mark_origin(&top_data);
init_top(NULL, 0, top_data);
module_data = read_fasl_data(merge_system_directory("module.o"));
enter_mark_origin(&module_data);
init_module(NULL, 0, module_data);
#endif
#ifdef AOSVS
#endif
load(merge_system_directory("autoload.lsp"));
}
*/
char *
merge_system_directory(s)
{
static char buff[MAXPATHLEN];
extern char *strcat();
strcpy(buff, system_directory);
return(strcat(buff, s));
}
vs_overflow()
{
if (vs_limit > vs_org + VSSIZE)
error("value stack overflow");
vs_limit += VSGETA;
FEerror("Value stack overflow.", 0);
}
bds_overflow()
{
--bds_top;
if (bds_limit > bds_org + BDSSIZE)
error("bind stack overflow");
bds_limit += BDSGETA;
FEerror("Bind stack overflow.", 0);
}
frs_overflow()
{
--frs_top;
if (frs_limit > frs_org + FRSSIZE)
error("frame stack overflow");
frs_limit += FRSGETA;
FEerror("Frame stack overflow.", 0);
}
ihs_overflow()
{
--ihs_top;
if (ihs_limit > ihs_org + IHSSIZE)
error("invocation history stack overflow");
ihs_limit += IHSGETA;
FEerror("Invocation history stack overflow.", 0);
}
cs_overflow()
{
#ifdef AV
if (cs_limit < cs_org - cssize)
error("control stack overflow");
cs_limit -= CSGETA;
#endif
#ifdef MV
#endif
FEerror("Control stack overflow.", 0);
}
end_of_file()
{
error("end of file");
}
error(s)
{
printf("\nUnrecoverable error: %s.\n", s);
fflush(stdout);
#ifdef UNIX
abort();
#endif
#ifdef AOSVS
#endif
}
Lby()
{
#ifdef UNIX
int i;
if (vs_top - vs_base == 0)
i = 0;
else if (vs_top - vs_base == 1) {
if (type_of(vs_base[0]) == t_fixnum)
i = fix(vs_base[0]);
else
FEerror("Illegal exit code: ~S.", 1, vs_base[0]);
} else
too_many_arguments();
printf("Bye.\n");
exit(i);
#endif
#ifdef AOSVS
#endif
}
c_trace()
{
#ifdef AOSVS
#endif
}
siLargc()
{
check_arg(0);
vs_push(make_fixnum(ARGC));
}
siLargv()
{
int i;
check_arg(1);
if (type_of(vs_base[0]) != t_fixnum ||
(i = fix(vs_base[0])) < 0 ||
i >= ARGC)
FEerror("Illegal argument index: ~S.", 1, vs_base[0]);
vs_base[0] = make_simple_string(ARGV[i]);
}
#ifdef UNIX
siLgetenv()
{
char name[256];
int i;
char *value;
extern char *getenv();
check_arg(1);
check_type_string(&vs_base[0]);
if (vs_base[0]->st.st_fillp >= 256)
FEerror("Too long name: ~S.", 1, vs_base[0]);
for (i = 0; i < vs_base[0]->st.st_fillp; i++)
name[i] = vs_base[0]->st.st_self[i];
name[i] = '\0';
if ((value = getenv(name)) != NULL)
vs_base[0] = make_simple_string(value);
else
vs_base[0] = Cnil;
}
#endif
object *vs_marker;
siLmark_vs()
{
check_arg(0);
vs_marker = vs_base;
vs_base[0] = Cnil;
}
siLcheck_vs()
{
check_arg(0);
if (vs_base != vs_marker)
FEerror("Value stack is flawed.", 0);
vs_base[0] = Cnil;
}
siLreset_stack_limits(arg)
{
check_arg(0);
if (vs_top < vs_org + VSSIZE)
vs_limit = vs_org + VSSIZE;
else
error("can't reset vs_limit");
if (bds_top < bds_org + BDSSIZE)
bds_limit = bds_org + BDSSIZE;
else
error("can't reset bds_limit");
if (frs_top < frs_org + FRSSIZE)
frs_limit = frs_org + FRSSIZE;
else
error("can't reset frs_limit");
if (ihs_top < ihs_org + IHSSIZE)
ihs_limit = ihs_org + IHSSIZE;
else
error("can't reset ihs_limit");
#ifdef AV
if (&arg > cs_org - cssize + 16)
cs_limit = cs_org - cssize;
#endif
#ifdef MV
#endif
else
error("can't reset cs_limit");
vs_base[0] = Cnil;
}
siLinit_system()
{
check_arg(0);
init_system();
vs_base[0] = Cnil;
}
siLaddress()
{
check_arg(1);
vs_base[0] = make_fixnum((int)vs_base[0]);
}
siLnani()
{
check_arg(1);
vs_base[0] = (object)fixint(vs_base[0]);
}
siLinitialization_failure()
{
check_arg(0);
printf("lisp initialization failed\n");
exit(0);
}
Lidentity()
{
check_arg(1);
}
Llisp_implementation_version()
{
check_arg(0);
vs_push(make_simple_string(lisp_implementation_version));
vs_base[0] = Cnil;
}
siLsave_system()
{
int i;
#ifdef AOSVS
#endif
saving_system = TRUE;
GBC(t_contiguous);
#ifdef BSD
brk(core_end);
#endif
#ifdef DGUX
#endif
#ifdef AOSVS
#endif
cbgbccount = 0;
rbgbccount = 0;
for (i = 0; i < (int)t_end; i++)
tm_table[i].tm_gbccount = 0;
Lsave();
saving_system = FALSE;
alloc_page(-(holepage+nrbpage));
}
init_main()
{
make_function("BY", Lby);
make_function("BYE", Lby);
make_function("IDENTITY", Lidentity);
siStop_level=make_si_ordinary("TOP-LEVEL");
enter_mark_origin(&siStop_level);
make_si_function("ARGC", siLargc);
make_si_function("ARGV", siLargv);
#ifdef UNIX
make_si_function("GETENV", siLgetenv);
#endif
make_si_function("MARK-VS", siLmark_vs);
make_si_function("CHECK-VS", siLcheck_vs);
make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits);
make_si_function("INIT-SYSTEM", siLinit_system);
make_si_function("ADDRESS", siLaddress);
make_si_function("NANI", siLnani);
make_si_function("INITIALIZATION-FAILURE",
siLinitialization_failure);
make_function("LISP-IMPLEMENTATION-VERSION",
Llisp_implementation_version);
siVlisp_maxpages =
make_si_special("*LISP-MAXPAGES*", make_fixnum(real_maxpage));
siClisp_pagesize =
make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE));
siVsystem_directory =
make_si_special("*SYSTEM-DIRECTORY*",
make_simple_string(system_directory));
make_special("*FEATURES*",
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil)));
#ifdef VAX
make_special("*FEATURES*",
make_cons(make_ordinary("VAX"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("BSD"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))));
#endif
#ifdef SUN
make_special("*FEATURES*",
make_cons(make_ordinary("SUN"),
make_cons(make_ordinary("MC68K"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("BSD"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))))));
#endif
#ifdef SUN2R3
make_special("*FEATURES*",
make_cons(make_ordinary("SUN"),
make_cons(make_ordinary("MC68K"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("BSD"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))))));
#endif
#ifdef SUN3
make_special("*FEATURES*",
make_cons(make_ordinary("SUN"),
make_cons(make_ordinary("MC68020"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("BSD"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))))));
#endif
#ifdef NEWS
make_special("*FEATURES*",
make_cons(make_ordinary("NEWS"),
make_cons(make_ordinary("MC68020"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("BSD"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))))));
#endif
#ifdef ISI
#endif
#ifdef SEQ
#endif
#ifdef IBMRT
#endif
#ifdef ATT3B2
make_special("*FEATURES*",
make_cons(make_ordinary("ATT3B2"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("SYSTEM-V"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil)))))));
#endif
#ifdef S3000
make_special("*FEATURES*",
make_cons(make_ordinary("S3300"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("SYSTEM-V"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))));
#endif
#ifdef E15
make_special("*FEATURES*",
make_cons(make_ordinary("E15"),
make_cons(make_ordinary("MC68K"),
make_cons(make_ordinary("IEEE-FLOATING-POINT"),
make_cons(make_ordinary("UNIX"),
make_cons(make_ordinary("UNIPLUS-SYSTEM-V"),
make_cons(make_ordinary("COMMON"),
make_cons(make_ordinary("KCL"), Cnil))))))));
#endif
#ifdef DGUX
#endif
#ifdef AOSVS
#endif
make_si_function("SAVE-SYSTEM", siLsave_system);
}